home *** CD-ROM | disk | FTP | other *** search
- program Eliza;
-
- {=========================================================}
- { Keywords }
- {=========================================================}
- const MaxKey = 37;
- type KeyWordArray = array[1..MaxKey] of string[14];
- const KeyWords : KeyWordArray = (
- 'CAN YOU','CAN I','YOU ARE','YOU''RE','I DON''T',
- 'I FEEL','WHY DON''T YOU','WHY CAN''T I','ARE YOU',
- 'I CAN''T','I AM','I''M','YOU','I WANT','WHAT',
- 'HOW','WHO','WHERE','WHEN','WHY','NAME','CAUSE',
- 'SORRY','DREAM','HELLO','HI','MAYBE','NO',
- 'YOUR','ALWAYS','THINK','ALIKE','YES','FRIEND',
- 'COMPUTER','NO KEY FOUND','REPEAT INPUT');
-
- {=========================================================}
- { Data for finding the right responses }
- {=========================================================}
-
- const RespFn = 'RESPONSE.DAT'; {response data file}
- MaxRespNum = 116;
-
- type KeyNumArray = array[1..MaxKey] of word;
-
- var RspIndex:KeyNumArray; {- working response pointer array -}
-
- {- this array contains the start index to the response strings -}
- const KeyIndex : KeyNumArray =
- (1, 4, 6, 6,10,14,17,20,22,25,
- 28,28,32,35,40,40,40,40,40,40,
- 49,51,55,59,63,63,64,69,74,76,
- 80,83,90,93,99,106,113);
-
- {- this array contains the end index to the response strings -}
- const KeyEnd : KeyNumArray =
- (3, 5, 9, 9,13,16,19,21,24,27,
- 32,32,34,39,48,48,48,48,48,48,
- 50,54,58,62,68,63,68,73,75,79,
- 82,89,92,98,105,112,116);
-
- {=========================================================}
- { String data for conjugations }
- {=========================================================}
-
- const MaxCon = 7;
- type ConStr = string[8];
- ConjArray = array[1..MaxCon] of ConStr;
- const Con1 : ConjArray =
- (' are ',' we''re ',' you ',' your ',' I''ve ',' I''m ',' me ');
- Con2 : ConjArray =
- (' am ',' was ',' I ',' my ',' you''ve ',' you''re ',' !you ');
-
-
- {=========================================================}
- { Other misc information needed by the program }
- {=========================================================}
-
- {- possible punctuation -}
- const PuncSet = [' ','.','!','?',','];
-
- {- misc error messages -}
- const NoFileMsg = 'Sorry, I seem to have mis-placed the response files.';
- LogicErrMsg = 'Hmmm, I seem to be having problems myself.';
-
-
- {=========================================================}
- { drop leading and trailing spaces and punctuation }
- {=========================================================}
- procedure Ctrim(var Xstr:string);
- begin
- while (length(Xstr) > 0) and (Xstr[1] in PuncSet) do
- delete(Xstr,1,1);
- while (length(Xstr) > 0) and (Xstr[length(Xstr)] in PuncSet) do
- dec(Xstr[0]);
- end;
-
- {=========================================================}
- { return a string in upper case }
- {=========================================================}
- function UpCopy(Wstr:string; Pos,Cnt:byte):string;
- var Xstr:string;
- i:integer;
- begin
- Xstr[0] := #0;
- for i := 1 to Cnt do
- begin
- inc(Xstr[0]);
- Xstr[i] := upcase(Wstr[pred(Pos+i)]);
- end;
- UpCopy := Xstr;
- end;
-
- {=========================================================}
- { Find keyword in Wstr }
- {=========================================================}
- {- a keyword is a relational word that we can respond to }
- {- see the keyword table to see the types of relational words}
- {- that are used. Returns "Key" pointing to keyword in table,}
- {- returns "Kpos" pointing to first char after keyword in Wstr}
- {- Returns function true if keyword found, or false if not}
- {- if no keyword found Key = pred(MaxKey), repeated string = MaxKey}
-
- function FindKey(Wstr:string; var Kpos,Key:word):boolean;
- var Xstr:string;
- label Found;
- begin
- Xstr := UpCopy(Wstr,1,length(Wstr));
- Key := 0;
- while Key < pred(MaxKey) do
- begin
- inc(Key);
- Kpos := pos(KeyWords[Key],Xstr);
- if Kpos > 0 then goto Found;
- end;
- FindKey := false;
- Exit;
-
- Found:
- Kpos := Kpos + Length(KeyWords[Key]);
- FindKey := true;
- end;
-
-
- {=========================================================}
- { Take the right part of the string and conjugate it }
- { using the list of strings to be swapped }
- {=========================================================}
-
- procedure Conjugate(var Wstr,Cstr:string; Kpos:word);
- var i,Cp:word;
-
- {- try to conjugate the string -}
- function ConSwap(var Cs1,Cs2:ConStr):boolean;
- begin
- ConSwap := false;
- if UpCopy(Cstr,Cp,length(Cs1)) = UpCopy(Cs1,1,length(Cs1)) then
- begin
- Cstr := copy(Cstr,1,pred(Cp))+Cs2+
- copy(Cstr,Cp+length(Cs1),length(Cstr));
- Cp := pred(Cp+length(Cs2));
- ConSwap := true;
- end
- end;
-
- {-procedure Conjugate-}
- begin
- Cstr := copy(Wstr,Kpos,length(Wstr)); {pull out the right part}
- Ctrim(Cstr); {clean it up}
- if length(Cstr) = 0 then Cstr := Wstr; {if empty use entire string}
- Cstr := ' '+Cstr+' '; {add working spaces}
-
- for i := 1 to MaxCon do
- begin
- Cp := 0;
- while Cp < length(Cstr) do
- begin
- inc(Cp);
- if not(ConSwap(Con1[i],Con2[i])) then
- if ConSwap(Con2[i],Con1[i]) then {nop};
- end;
- end;
-
- {- clean up the conjugated string -}
- Cp := 1;
- while Cp < length(Cstr) do
- if Cstr[Cp] = '!' then Delete(Cstr,Cp,1) else inc(Cp);
- Ctrim(Cstr);
-
- {- special case fixup for trailing 'I's -}
- if Cstr[length(Cstr)] = 'I' then
- begin
- dec(Cstr[0]);
- Cstr := Cstr+'me';
- end;
- end;
-
-
- {============================================================}
- { Reads a response from the response file }
- {============================================================}
- procedure ReadResp(var Rstr:string; RespNum:word);
- var i:integer;
- Respfile:text;
- label NoFileErr,LogicErr;
- begin
- if (RespNum = 0) or (RespNum > MaxRespNum) then goto LogicErr;
-
- {- find the desired response in the response file -}
- {$I-}
- assign(Respfile,RespFn);
- reset(Respfile);
- for i := 1 to pred(RespNum) do
- Readln(Respfile); {skip down to the desired response}
- Readln(Respfile,Rstr); {read it}
- close(Respfile); {and close the file}
- {$I+}
- if IOResult <> 0 then goto NoFileErr; {check for errors}
- Exit;
-
- {- couldn't find the file, or a read error occured -}
- NoFileErr:
- Rstr := NoFileMsg;
- Exit;
-
- {- invalid response number given -}
- LogicErr:
- Rstr := LogicErrMsg;
- end;
-
-
- {============================================================}
- { Get a response based on the keyword number in variable Key }
- {============================================================}
-
- procedure GetResponse(var Rstr:string; Key:word);
- var Fstr:string;
- label QAppend,PAppend;
- begin
- ReadResp(Fstr,RspIndex[Key]); {get the desired response from data file}
-
- {-Point to the next response so that no two are the same}
- inc(RspIndex[Key]);
- if RspIndex[Key] > KeyEnd[Key] then RspIndex[Key] := KeyIndex[Key];
-
- {-if no "*" or "@" at the end of the response, then just return the response}
- {-if there was an "*" at the end of the response string, then return}
- {-the response plus the conjugation word/phrase in Rstr plus a "?"}
- {-if "@" then add a period instead}
- if Fstr[length(Fstr)] = '*' then goto QAppend;
- if Fstr[length(Fstr)] = '@' then goto PAppend;
- Rstr := Fstr;
- Exit;
-
- {- replace the '*' with a space, append the conjugated string and add "?" -}
- QAppend:
- Fstr[length(Fstr)] := ' ';
- Rstr := Fstr+Rstr+'?';
- Exit;
-
- {- replace the '@' with a space, append the conjugated string and add "." -}
- PAppend:
- Fstr[length(Fstr)] := ' ';
- Rstr := Fstr+Rstr+'.';
- end;
-
-
- {============================================================}
- {- program Eliza -}
-
- var Key,Kpos:word; {- key word pointers -}
- Istr,Pstr,Cstr:string; {- operational strings -}
-
- begin
- RspIndex := KeyIndex; {- start the index array -}
- writeln;
- writeln('Hi! I''m Eliza. I am your personal therapy computer.');
- writeln('Please tell me your problem.');
- writeln;
-
- while true do
- begin
- readln(Istr);
- Ctrim(Istr); {- strip out any extra blanks from work string -}
- Cstr := UpCopy(Istr,1,length(Istr));
- if (Cstr = 'STOP') or (Cstr = 'QUIT') then Halt;
-
- Key := MaxKey; {- set max for repeat input -}
- if Cstr <> Pstr then {- get new key if not repeat -}
- if FindKey(Cstr,Kpos,Key) then {- If keyword found in Istr -}
- Conjugate(Istr,Cstr,Kpos); {- then conjugate the string -}
-
- Pstr := UpCopy(Istr,1,length(Istr)); {- save original input string -}
- GetResponse(Cstr,Key); {- Get response based on Keyword found -}
- writeln(Cstr); {- and print the response -}
- end;
- end.
-
-